home *** CD-ROM | disk | FTP | other *** search
/ Fritz: All Fritz / All Fritz.zip / All Fritz / FILES / PROGMISC / FORTRAN1.LZH / EVAL.FOR < prev    next >
Text File  |  1988-02-08  |  8KB  |  285 lines
  1.       SUBROUTINE EVAL (TOKE, NTOKE, FACTS, TOP, NT, BOT, NB, FAC )
  2. C*
  3. C*                  *******************************
  4. C*                  *******************************
  5. C*                  **                           **
  6. C*                  **           EVAL            **
  7. C*                  **                           **
  8. C*                  *******************************
  9. C*                  *******************************
  10. C*
  11. C*     SUBPROGRAM :
  12. C*          EVALUATE
  13. C*
  14. C*     AUTHOR :
  15. C*          ART RAGOSTA
  16. C*          MS 207-5
  17. C*          AMES RESEARCH CENTER
  18. C*          MOFFETT FIELD, CALIF   94035
  19. C*          (415) 694-5578
  20. C*
  21. C*     PURPOSE :
  22. C*          TO EVALUATE THE REVERSE POLISH STRING, RESULTING IN A
  23. C*          FINAL SCALE FACTOR AND THE PROPER UNITS.
  24. C*
  25. C*     METHODOLOGY :
  26. C*          NA
  27. C*
  28. C*     INPUT ARGUMENTS :
  29. C*          TOKE  - THE LIST OF TOKENS IN REVERSE POLISH
  30. C*          NTOKE - THE NUMBER OF TOKENS IN 'TOKE'
  31. C*          FACTS - THE SCALE FACTORS FOR EACH ENTRY IN 'TOKE'
  32. C*
  33. C*     OUTPUT ARGUMENTS :
  34. C*          TOP   - THE LIST OF UNITS WHICH ARE IN THE NUMERATOR
  35. C*          NT    - THE NUMBER OF ENTRIES IN 'TOP'
  36. C*          BOT   - THE LIST OF UNITS WHICH ARE IN THE DENOMINATOR
  37. C*          NB    - THE NUMBER OF ENTRIES IN 'BOT'
  38. C*          FAC   - THE TOTAL SCALE FACTOR
  39. C*
  40. C*     INTERNAL WORK AREAS :
  41. C*          TFAC, BFAC  - STACKS FOR SCALE FACTORS
  42. C*          TSTACK, BSTACK - STACKS FOR UNIT STRINGS
  43. C*
  44. C*     COMMON BLOCKS :
  45. C*          NONE
  46. C*
  47. C*     FILE REFERENCES :
  48. C*          NONE
  49. C*
  50. C*     SUBPROGRAM REFERENCES :
  51. C*          LENGTH,  RIGHT
  52. C*
  53. C*     ERROR PROCESSING :
  54. C*          NONE
  55. C*
  56. C*     TRANSPORTABILITY LIMITATIONS :
  57. C*          NONE
  58. C*
  59. C*     ASSUMPTIONS AND RESTRICTIONS :
  60. C*          NONE
  61. C*
  62. C*     LANGUAGE AND COMPILER :
  63. C*          ANSI FORTRAN 77
  64. C*
  65. C*     VERSION AND DATE :
  66. C*          VERSION I.0      7-FEB-85
  67. C*
  68. C*     CHANGE HISTORY :
  69. C*           7-FEB-85    INITIAL VERSION
  70. C*
  71. C***********************************************************************
  72. C*
  73.       CHARACTER *600 BSTACK(50), TSTACK(50), T, T1, B, B1
  74.       CHARACTER *6 TOKE(1), TOP(1), BOT(1), TT
  75.       DOUBLE PRECISION FACTS(1), FAC, FSTACK(50)
  76. C
  77.       FAC  = 1.0D0
  78.       NT   = 0
  79.       NB   = 0
  80.       IF ( NTOKE .LE. 0 ) RETURN
  81.       ISP  = 0
  82. C
  83. C --- FIRST PASS, CALCULATE SCALE FACTOR
  84. C
  85.       DO 100 I = 1, NTOKE
  86. C
  87. C ----- FOR EXPONENTIATION, GET EXPONENT FROM TOKENS
  88. C
  89.          IF ( TOKE(I) .EQ. '^') THEN
  90.             TT = TOKE(I-1)
  91.             CALL RIGHT ( TT )
  92.             READ ( TT, 900, ERR=1000 ) NUM
  93.             FSTACK(ISP) = FSTACK(ISP)**NUM
  94. C
  95. C ----- MULTIPLY
  96. C
  97.          ELSE IF (TOKE(I) .EQ. '*') THEN
  98.             ISP = ISP - 1
  99.             FSTACK(ISP) = FSTACK(ISP) * FSTACK(ISP+1)
  100. C
  101. C ----- DIVIDE
  102. C
  103.          ELSE IF (TOKE(I) .EQ. '/') THEN
  104.             ISP = ISP - 1
  105.             FSTACK(ISP) = FSTACK(ISP) / FSTACK(ISP+1)
  106. C
  107. C ----- OTHERWISE THE TOKEN IS A UNIT
  108. C
  109.          ELSE
  110. C
  111. C -------- IF THE TOKEN IS NUMERIC, DO NOTHING---
  112. C --------  IF IT IS ALPHA, ADD FACTOR TO STACK
  113. C
  114.             IF ((TOKE(I)(1:1) .LT. '0') .OR.
  115.      $          (TOKE(I)(1:1) .GT. '9')) THEN
  116.                ISP       = ISP + 1
  117.                FSTACK(ISP) = FACTS(I)
  118.             ENDIF
  119.          ENDIF
  120. 100      CONTINUE
  121.       FAC = FSTACK(ISP)
  122. C
  123. C --- PASS 2, DETERMINE WHICH SYMBOLS ARE IN NUMERATOR AND DENOMINATOR
  124. C
  125.       NT   = 0
  126.       NB   = 0
  127.       ISP  = 0
  128.       DO 200 I = 1, NTOKE
  129. C
  130. C ----- FOR EXPONENTIATION, ADD THE STRING TO ITSELF 'NUM' TIMES.
  131. C
  132.          IF ( TOKE(I) .EQ. '^') THEN
  133.             TT   = TSTACK(ISP)
  134.             ISP = ISP - 1
  135.             CALL RIGHT ( TT )
  136.             READ ( TT, 900, ERR=1000 ) NUM
  137.             T1  = TSTACK(ISP)
  138.             B1  = BSTACK(ISP)
  139.             ISP = ISP - 1
  140.             T   = ' '
  141.             B   = ' '
  142.             IT  = 1
  143.             IB  = 1
  144.             LT  = LENGTH(T1)
  145.             LB  = LENGTH(B1)
  146.             IF (LT .GT. 0) THEN
  147.                DO 10 II = 1, NUM
  148.                   T(IT:IT+LT-1) = T1(1:LT)
  149.                   IT = IT + LT
  150.                   T(IT:IT) = '*'
  151.                   IT = IT + 1
  152. 10                CONTINUE
  153.             ENDIF
  154.             IF (LB .GT. 0) THEN
  155.                DO 15 II = 1, NUM
  156.                   B(IB:IB+LB-1) = B1(1:LB)
  157.                   IB = IB + LB
  158.                   B(IB:IB) = '*'
  159.                   IB = IB + 1
  160. 15                CONTINUE
  161.             ENDIF
  162.             IT       = IT - 1
  163.             IB       = IB - 1
  164.             T(IT:IT) = ' '
  165.             B(IB:IB) = ' '
  166.             ISP      = ISP + 1
  167.             TSTACK(ISP) = T
  168.             BSTACK(ISP) = B
  169. C
  170. C ----- FOR A MULTIPLY, ADD STRINGS FROM THE SAME SIDE OF THE STACK.
  171. C
  172.          ELSE IF (TOKE(I) .EQ. '*') THEN
  173.             T   = TSTACK(ISP)
  174.             B   = BSTACK(ISP)
  175.             ISP = ISP - 1
  176.             T1  = TSTACK(ISP)
  177.             B1  = BSTACK(ISP)
  178.             ISP = ISP - 1
  179.             LT  = LENGTH ( T )
  180.             LB  = LENGTH ( B )
  181.             LT1 = LENGTH ( T1 )
  182.             LB1 = LENGTH ( B1 )
  183. C
  184. C -------- CHECK TO SEE THAT THERE WAS AN ENTRY IN BOTH LOCATIONS
  185. C
  186.             IF ((LT .GT. 0) .AND. (LT1 .GT. 0)) THEN
  187.                LT = LT + 1
  188.                T(LT:LT) = '*'
  189.             ENDIF
  190.             IF ((LB .GT. 0) .AND. (LB1 .GT. 0)) THEN
  191.                LB = LB + 1
  192.                B(LB:LB) = '*'
  193.             ENDIF
  194.             LT  = LT + 1
  195.             LB  = LB + 1
  196.             IF (LT1 .GT. 0) THEN
  197.                T(LT:LT+LT1-1) = T1(1:LT1)
  198.             ENDIF
  199.             IF (LB1 .GT. 0) THEN
  200.                B(LB:LB+LB1-1) = B1(1:LB1)
  201.             ENDIF
  202.             ISP = ISP + 1
  203.             TSTACK(ISP) = T
  204.             BSTACK(ISP) = B
  205. C
  206. C ----- FOR A DIVIDE, ADD STRINGS FROM OPPOSITE SIDES OF THE STACK.
  207. C
  208.          ELSE IF (TOKE(I) .EQ. '/') THEN
  209.             T   = TSTACK(ISP)
  210.             B   = BSTACK(ISP)
  211.             ISP = ISP - 1
  212.             T1  = TSTACK(ISP)
  213.             B1  = BSTACK(ISP)
  214.             ISP = ISP - 1
  215.             LT  = LENGTH ( T )
  216.             LB  = LENGTH ( B )
  217.             LT1 = LENGTH ( T1 )
  218.             LB1 = LENGTH ( B1 )
  219.             IF ((LT1 .GT. 0) .AND. (LB .GT. 0)) THEN
  220.                LT1 = LT1 + 1
  221.                T1(LT1:LT1) = '*'
  222.             ENDIF
  223.             IF ((LB1 .GT. 0) .AND. (LT .GT. 0)) THEN
  224.                LB1 = LB1 + 1
  225.                B1(LB1:LB1) = '*'
  226.             ENDIF
  227.             LT1 = LT1 + 1
  228.             LB1 = LB1 + 1
  229.             IF (LB .GT. 0 ) THEN
  230.                T1(LT1:LT1+LB-1) = B(1:LB)
  231.             ENDIF
  232.             IF (LT .GT. 0 ) THEN
  233.                B1(LB1:LB1+LT-1) = T(1:LT)
  234.             ENDIF
  235.             ISP = ISP + 1
  236.             TSTACK(ISP) = T1
  237.             BSTACK(ISP) = B1
  238. C
  239. C ----- OTHERWISE THE TOKEN IS A UNIT, PUT IT ON THE TOP SIDE OF STACK
  240. C
  241.          ELSE
  242.             ISP       = ISP + 1
  243.             TSTACK(ISP) = TOKE(I)
  244.             BSTACK(ISP) = ' '
  245.          ENDIF
  246. 200      CONTINUE
  247. C
  248. C --- NOW PARSE THE TOP STRINGS INTO ARRAYS OF UNITS
  249. C
  250.       T   = TSTACK(ISP)
  251.       B   = BSTACK(ISP)
  252.       LT  = LENGTH ( T )
  253.       LB  = LENGTH ( B )
  254.       NT  = 0
  255.       NB  = 0
  256.       I   = 1
  257. 205   NT  = NT + 1
  258.       INT = 1
  259.       TOP(NT) = ' '
  260. 210   TOP(NT)(INT:INT) = T(I:I)
  261.       INT = INT + 1
  262.       I   = I + 1
  263.       IF (I .GT. LT) GO TO 250
  264.       IF (T(I:I) .NE. '*') GO TO 210
  265.       I   = I + 1
  266.       IF (I .LE. LT) GO TO 205
  267. C
  268. 250   I = 1
  269. 300   NB = NB + 1
  270.       INT = 1
  271.       BOT(NB) = ' '
  272. 310   BOT(NB)(INT:INT) = B(I:I)
  273.       INT = INT + 1
  274.       I = I + 1
  275.       IF (I .GT. LB) GO TO 1000
  276.       IF (B(I:I) .NE. '*') GO TO 310
  277.       I = I + 1
  278.       IF (I .LE. LB) GO TO 300
  279. 1000  RETURN
  280. 900   FORMAT ( I6 )
  281.       END
  282. C
  283. C---END EVAL
  284. C
  285.